home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / link / unvaxsuspend.t < prev   
Text File  |  1988-05-02  |  7KB  |  190 lines
  1. (herald unvaxsuspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (suspend obj out-spec x?)
  6.   (set (experimental?) x?)
  7.   (really-suspend obj out-spec 'o))
  8.  
  9. (define initial-symbol-count 0)
  10.  
  11. (define-constant RELOC-SIZE 8)
  12. (define-constant CYMBAL-SIZE 12)
  13. (define-constant OMAGIC #o407)
  14. (define-constant N_TEXT 4)
  15. (define-constant N_DATA 6)
  16. (define-constant N_UNDF 0)
  17. (define-constant N_EXT 1)
  18.  
  19. (define-constant DATA-RELOC (fixnum-logior N_DATA (fixnum-ashl 2 25)))
  20. (define-constant TEXT-RELOC (fixnum-logior N_TEXT (fixnum-ashl 2 25)))
  21. (define-constant UNDEFINED-RELOC (fixnum-logior (fixnum-ashl 2 25)
  22.                                                 (fixnum-ashl 1 27)))
  23. (define-constant DATA-EXTERNAL (fixnum-logior DATA-RELOC N_EXT))
  24.  
  25. (define (vgc-foreign foreign)
  26.   (let* ((heap (lstate-impure *lstate*))
  27.          (addr (+area-frontier heap))
  28.          (name (foreign-name foreign))
  29.          (desc (object nil
  30.                  ((heap-stored self) (lstate-impure *lstate*))
  31.                  ((heap-offset self) addr)
  32.                  ((write-descriptor self stream)
  33.                   (write-data stream (fx+ addr tag/extend)))
  34.                  ((write-store self stream)
  35.                   (write-int stream header/foreign)
  36.                   (write-slot name stream)
  37.                   (write-int stream 0)))))
  38.     (set (+area-frontier heap) (fx+ addr 12))
  39.     (push (+area-objects heap) desc)
  40.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  41.     (generate-slot-relocation name (fx+ addr 4))
  42.     (cymbal-thunk (symbol->string name) (fixnum-logior N_UNDF N_EXT) 0)
  43.     (reloc-thunk (fixnum-logior (lstate-symbol-count *lstate*) UNDEFINED-RELOC)
  44.                  (fx+ addr 8))
  45.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  46.     desc))
  47.  
  48.  
  49. (define (generate-slot-relocation obj slot-address)
  50.   (cond ((or (fixnum? obj) (immediate? obj)))
  51.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  52.          (reloc-thunk DATA-RELOC slot-address))
  53.         (else
  54.          (reloc-thunk TEXT-RELOC slot-address))))
  55.  
  56.         
  57.  
  58. (define (reloc-thunk type address)
  59.   (push (lstate-data-reloc *lstate*)
  60.         (cons address type)))
  61.  
  62. (define (text-relocation addr)
  63.   (reloc-thunk TEXT-RELOC addr))
  64.  
  65. (define (data-relocation addr)
  66.   (reloc-thunk DATA-RELOC addr))
  67.         
  68.                          
  69. (define (write-slot obj stream)
  70.   (cond ((fixnum? obj)
  71.          (write-fixnum stream obj))
  72.         ((immediate? obj)
  73.          (write-immediate stream obj))
  74.         ((null? obj)
  75.          (write-descriptor (lstate-null *lstate*) stream))
  76.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  77.          => (lambda (desc) (write-descriptor desc stream)))
  78.         (else
  79.          (error "bad immediate type ~s" obj))))
  80.  
  81.  
  82.  
  83. (define-integrable (write-data stream int)
  84.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  85.  
  86. (define (write-immediate stream imm)
  87.   (let ((int (descriptor->fixnum imm)))
  88.     (write-half stream (fx+ (fixnum-ashl int 2) 1))
  89.     (write-half stream (fixnum-ashr int 14))))
  90.  
  91.  
  92. (define (write-scratch stream obj i)
  93.   (let ((offset (fixnum-ashl i 2)))
  94.     (write-half stream (mref-16-u obj offset))
  95.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  96.  
  97. (define (write-int stream int)
  98.   (write-half stream int)
  99.   (let ((int (fixnum-ashr int 16)))
  100.     (write-half stream int)))
  101.  
  102. (define (write-half stream int)
  103.   (vm-write-byte stream int)
  104.   (let ((int (fixnum-ashr int 8)))
  105.     (vm-write-byte stream int)))
  106.  
  107. (define (write-fixnum stream fixnum)
  108.   (write-half stream (fixnum-ashl fixnum 2))
  109.   (write-half stream (fixnum-ashr fixnum 14)))
  110.  
  111. (define (cymbal-thunk stryng type value)
  112.  (push (lstate-symbols *lstate*)
  113.   (object (lambda (stream a)
  114.             ;; a is offset into stryng table
  115.             (write-int stream a)
  116.             (vm-write-byte stream type)
  117.             (vm-write-byte stream 0)       ; other
  118.             (write-half stream 0)       ; see <stab.h>                 
  119.             (if (fixnum? value)            ; undefined external (foreign)
  120.                 (write-int stream 0)
  121.                 (write-descriptor value stream)))
  122.           ((cymbal-thunk.stryng self) stryng))))
  123.  
  124. (define-operation (cymbal-thunk.stryng thunk))
  125.  
  126. (define (make-global-cymbal proc name)
  127.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  128.        => (lambda (desc)                                
  129.             (cymbal-thunk (string-downcase! (symbol->string name))
  130.                           (fixnum-logior N_DATA N_EXT)
  131.                           desc)
  132.             (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  133.         (else
  134.          (error "~s not defined" name))))
  135.  
  136.  
  137.  
  138. (define (write-link-file stream)                
  139.   (make-global-cymbal big_bang 'big_bang)
  140.   (make-global-cymbal interrupt_dispatcher 'interrupt_dispatcher)
  141.   (write-header     stream)
  142.   (write-out-area       stream (lstate-pure *lstate*))
  143.   (write-out-area       stream (lstate-impure *lstate*))
  144.   (write-relocation stream (lstate-data-reloc *lstate*))  
  145.   (write-cymbal&stryng-table stream (reverse (lstate-symbols *lstate*))))
  146.  
  147. (define (write-header stream)
  148.   (let* ((text-size (+area-frontier (lstate-pure *lstate*)))
  149.          (data-size (+area-frontier (lstate-impure *lstate*))))
  150.     (write-int stream OMAGIC)                 ;magic number
  151.     (write-int stream text-size)              ;text segment size
  152.     (write-int stream data-size)              ;data segment size
  153.     (write-int stream 0)                      ;bss  segment size
  154.     (write-int stream (fx* CYMBAL-SIZE (lstate-symbol-count *lstate*)))
  155.     (write-int stream 0)                      ;bogus entry point
  156.     (write-int stream 0)                      ; no text relocation
  157.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))))
  158.  
  159. (define (write-out-area stream area)
  160.   (walk (lambda (x) (write-store x stream))
  161.         (reverse! (+area-objects area))))
  162.  
  163.  
  164. (define (write-relocation stream items)
  165.   (walk (lambda (item)
  166.           (write-int stream (car item))
  167.           (write-int stream (cdr item)))
  168.         items))
  169.           
  170.                              
  171. (define (write-cymbal&stryng-table stream cyms)
  172.   (let ((z (write-cyms stream cyms))) ; cymbal table
  173.     (write-int stream z)       ; size of stryng table
  174.     (walk (lambda (s)             ; write stryng table
  175.             (write-string stream (cymbal-thunk.stryng s))
  176.             (vm-write-byte stream 0))
  177.            cyms)))
  178.  
  179. (define (write-cyms stream cyms)
  180.   (iterate loop ((a 4)                      ;; 4 bytes for size of stryng table
  181.                  (l cyms))
  182.     (cond ((null? l) a)
  183.           (else
  184.            (let ((e (car l)))
  185.              (e stream a)
  186.              (loop (fx+ (fx+ a (string-length (cymbal-thunk.stryng e))) 1) ;null
  187.                    (cdr l)))))))
  188.  
  189.  
  190.